home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1996 #14 / Monster Media No. 14 (April 1996) (Monster Media, Inc.).ISO / netmail / txtq130.zip / ROBOQ.PAS < prev    next >
Pascal/Delphi Source File  |  1996-01-26  |  8KB  |  263 lines
  1. {$M 10240,0,655360}  { 10k reserved for data }
  2. {$N-,E- no math support needed}
  3. {$X- function calls may not be discarded}
  4. {$I- disable I/O checking (trap errors by checking IOResult)}
  5.  
  6. PROGRAM Convert_ROBOMAIL_Textfiles_to_QWK;
  7. USES
  8.   DOS,
  9.   TXTQ;
  10. VAR
  11.   SavedExitProc: POINTER;
  12.   
  13. {===========================================================================}
  14.  
  15. PROCEDURE CustomExit; FAR;
  16. {---- Always exit through here ----}
  17. BEGIN
  18.   ExitProc := SavedExitProc;
  19.   cursorOn;
  20.   Cleanup;
  21.   IF (ExitCode > 0) THEN BEGIN
  22.     WriteLn;
  23.     WriteLn ('ROBOQ - Free DOS utility: Convert Robomail "Text files" to QWK files.');
  24.     WriteLn (author);
  25.     WriteLn;
  26.     WriteLn ('Usage:  ROBOQ <Robomail "Text file(s)">   (DOS wildcards are permitted.)');
  27.     WriteLn;
  28.     WriteLn ('Example:  ROBOQ startrek.msg              (creates "STARTREK.Q??")');
  29.     WriteLn;
  30.   END;
  31.   IF ErrorAddr <> NIL THEN
  32.   BEGIN
  33.     WriteLn ('An unanticipated error occurred, please contact DDA with the following data:');
  34.     WriteLn ('Address = ', Seg (ErrorAddr^), ':', Ofs (ErrorAddr^));
  35.     WriteLn ('Code    = ', ExitCode);
  36.     ErrorAddr := NIL;
  37.   END
  38.   ELSE
  39.     IF (ExitCode > 0) AND (ExitCode < 255) THEN
  40.       WriteErr (ExitCode);
  41. END;
  42.  
  43. FUNCTION GetMsgDate (datestr: STRING): STRING;
  44. BEGIN
  45.   datestr [3] := #45;  { replace '/' with '-' }
  46.   datestr [6] := #45;
  47.   GetMsgDate := datestr;
  48. END;
  49.  
  50. FUNCTION GetMsgStat (MsgStat: CHAR): CHAR;
  51. (* Note: the meaning of the status flag in the header of the QWK format
  52.          specification is interpreted differently by different products.
  53.  
  54.    According to Patrick Y. Lee's "QWK Mail Packet File Layout" v1.0
  55.    and Robomail v1.30, an asterisk ('*') means private and received,
  56.                  and the plus sign ('+') means private and NOT received.
  57.  
  58.    SLMR, OLX, and SPEED seem to agree that the meaning of the two
  59.    symbols is reversed.
  60.  
  61.    Since this is a Robomail utility, I've used the latter.  Thus, the
  62.    private/ public flag will be translated into the following symbols:
  63.  
  64.               public, unread   =  ' '  (#32)
  65.               private, unread  =  '+'  (#43)
  66. *)
  67. BEGIN
  68.   IF MsgStat = 'u'
  69.   THEN GetMsgStat := #32   { unread, public }
  70.   ELSE GetMsgStat := #43;  { unread, private }
  71. END;
  72.  
  73. FUNCTION ExtractBBSname (dataline: STRING): STRING;
  74. {Origin: CHANNEL1 - 0113 - Share}
  75. BEGIN
  76.   IF (Pos (' - ', dataline) > 0) THEN
  77.     Delete (dataline, Pos (' - ', dataline), Length (dataline));
  78.   IF (Pos (#32, dataline) > 0) THEN
  79.     Delete (dataline, 1, Pos (#32, dataline));
  80.   ExtractBBSname := Trim (dataline);
  81. END;
  82.  
  83. FUNCTION ExtractConfNumber (dataline: STRING): STRING;
  84. {Origin: CHANNEL1 - 0113 - Share}
  85. BEGIN
  86.   IF (Pos (' - ', dataline) > 0) THEN BEGIN
  87.     Delete (dataline, 1, 2 + Pos (' - ', dataline));
  88.     IF (Pos (' - ', dataline) > 0)
  89.     THEN dataline := Copy (dataline, 1, Pos (' - ', dataline) - 1)
  90.     ELSE dataline := '0';
  91.   END
  92.   ELSE
  93.     dataline := '0';
  94.   ExtractConfNumber := dataline;
  95. END;
  96.  
  97. FUNCTION ExtractConfName (dataline: STRING): STRING;
  98. {Origin: CHANNEL1 - 0113 - Share}
  99. BEGIN
  100.   WHILE (Pos (' - ', dataline) > 0) DO
  101.     Delete (dataline, 1, 2 + Pos (' - ', dataline));
  102.   dataline := Trim (dataline);
  103.   IF dataline = '' THEN dataline := 'Unknown';
  104.   ExtractConfName := dataline;
  105. END;
  106.  
  107. FUNCTION ReadMsgHeader (VAR MsgFile: FILE; VAR MsgNum: WORD): STRING;
  108. CONST
  109.   hyphens = '-----------------------------------';
  110.   password = #32#32#32#32#32#32#32#32#32#32#32#32; { 12 spaces }
  111.   chunks = #32#32#32#32#32#32;  { 6 spaces }
  112. VAR
  113.   C_Line: STRING;
  114.   MsgFrom, MsgTo, subj: STRING [25];
  115.   MsgDate: STRING [8];  MsgTime: STRING [5];
  116.   MsgNumStr: STRING [7];  ReferN: STRING [8];
  117.   ConfNumb: STRING [5];  MsgStat: CHAR;
  118.   ConfName: STRING;
  119.   Count: BYTE;
  120.   
  121. BEGIN
  122.   REPEAT
  123.     ReadStr (MsgFile, C_Line); CheckIO; Inc (lineNumb);
  124.   UNTIL (EoF (MsgFile)) OR (Copy (C_Line, 1, 8) = ('Origin: '));
  125.   IF EoF (MsgFile) THEN
  126.     ReadMsgHeader := ''
  127.   ELSE BEGIN
  128.     IF BBSname = '' THEN
  129.       BBSname := ExtractBBSname (C_Line);
  130.     
  131.     ConfNumb := StrToDoubleChar (ExtractConfNumber (C_Line));
  132.     ConfName := ExtractConfName (C_Line);
  133.     
  134.     AddConfToList (ConfNumb, ConfName);
  135.     AddMsgToList (ConfNumb, Blocks);
  136.     
  137.     FOR count := 1 TO 2 DO BEGIN
  138.       ReadStr (MsgFile, C_Line); CheckIO; Inc (lineNumb);
  139.       IF Copy (C_Line, 1, 7) = ('    To:') THEN
  140.         MsgTo := RPad (Copy (C_Line, 9, Length (C_Line) - 8), 25, #32)
  141.       ELSE BEGIN
  142.         IF Copy (C_Line, 1, 7) = ('  From:') THEN BEGIN
  143.           MsgFrom := Copy (C_Line, 9, 25);
  144.           MsgStat := GetMsgStat (C_Line [40]);
  145.         END;
  146.       END;
  147.     END;
  148.     
  149.     ReadStr (MsgFile, C_Line); CheckIO; Inc (lineNumb);
  150.     Verify (C_Line, '  Date:', 1);
  151.     MsgDate := GetMsgDate (Copy (C_Line, 9, 8));
  152.     MsgTime := Copy (C_Line, 21, 5);
  153.     
  154.     ReadStr (MsgFile, C_Line); CheckIO; Inc (lineNumb);
  155.     Verify (C_Line, '    Re:', 1);
  156.     subj := RPad (Copy (C_Line, 9, Length (C_Line) - 8), 25, #32);
  157.     
  158.     ReadStr (MsgFile, C_Line); CheckIO; Inc (lineNumb);
  159.     Verify (C_Line, hyphens, 1);                       {discard hyphen C_Line}
  160.     
  161.     Inc (MSGnum);
  162.     Str (MSGnum, MsgNumStr);
  163.     MsgNumStr := RPad (MsgNumStr, 7, #32);
  164.     ReferN := RPad ('0', 8, #32);
  165.  
  166.     ReadMsgHeader := (MsgStat + MsgNumStr + MsgDate+ MsgTime+ {  1+7+8+5 = 21 }
  167.     MsgTo + MsgFrom + subj +               { 25+25+25 = 75 }
  168.     password + ReferN + chunks + #225 +    { 12+8+6+1 = 27 }
  169.     ConfNumb + #0#0#42);                   { 2+3      =  5 }
  170.   END;
  171. END;
  172.  
  173. {===========================================================================}
  174.  
  175. CONST SepLine = '<*>';
  176.   
  177. VAR
  178.   MSGnum : WORD;
  179.   Msgname: PATHSTR;
  180.   Msgext : EXTSTR;
  181.   Msgfile: FILE;     DATfile : FILE;
  182.   Msgline: STRING;   Message : MsgArray;
  183.   index, bytes, chunks: WORD;
  184.   Compressor : PATHSTR;
  185.  
  186.   dirinfo   : SEARCHREC;  { contains filespec info. }
  187.   spath     : PATHSTR;    { source file path and    }
  188.   sdir      : DIRSTR;     {             directory   }
  189.   filesdone : WORD;
  190.  
  191. BEGIN
  192.   SavedExitProc := ExitProc;
  193.   ExitProc := @CustomExit;
  194.  
  195.   IF ParamCount <> 1
  196.     THEN Halt (255)
  197.     ELSE spath := GetFilePath (ParamStr (1), sDir);
  198.  
  199.   FindFirst (spath, Archive, dirinfo);
  200.   filesdone := 0;
  201.  
  202.   MkDir (TXTQ_DIR); CheckIO;
  203.   ChDir (TXTQ_DIR); CheckIO;
  204.  
  205.   WHILE (DosError = 0) DO BEGIN
  206.     BBSname := '';
  207.     ConfList := NIL;
  208.     MsgList := NIL;
  209.     Conferences := 0;
  210.     MsgNum := 0;
  211.  
  212.     Inc (filesdone);
  213.     Msgname := sdir + dirinfo. Name;
  214.     PrepareFiles (Msgname, Msgext, Msgfile, DATfile);
  215.     Blocks := 0;
  216.     Chunks := 2;
  217.     Msgline := SepLine;
  218.     REPEAT
  219.       IF (NOT EoF (Msgfile)) AND (RTrim (Msgline) = SepLine) THEN BEGIN
  220.         bytes := 0;  updateCursor;
  221.         Inc (Blocks, chunks);
  222.         Msgline := ReadMsgHeader (Msgfile, MsgNum);
  223.         IF Msgline <> '' THEN BEGIN
  224.           WHILE (NOT EoF (Msgfile)) AND (RTrim (Msgline) <> SepLine) DO BEGIN
  225.             IF (bytes < MaxBytes) THEN
  226.               bytes := AddToArray (Message, bytes, Msgline);
  227.             ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb);
  228.           END;
  229.           IF (bytes > MaxBytes) THEN bytes := MaxBytes;
  230.           WHILE (Message [bytes] = #227) AND (Message [bytes - 1] = #227) DO
  231.             Dec (bytes);
  232.           
  233.           index := AddToArray (Message, 116, FigureMSGsize (bytes, chunks));
  234.           IF (chunks > 1) THEN BEGIN
  235.             FOR index := (bytes + 1) TO (chunks * 128) DO
  236.               Message [index] := #32;
  237.           END;
  238.           
  239.           BlockWrite (DATfile, Message, chunks * 128); CheckIO;
  240.         END
  241.       END
  242.       ELSE BEGIN
  243.         ReadStr (Msgfile, Msgline); CheckIO; Inc (lineNumb); {discard invalid lines}
  244.       END;
  245.     UNTIL EoF (Msgfile);
  246.     
  247.     Close (Msgfile); CheckIO;
  248.     Close (DATfile); CheckIO;
  249.     WriteLn ('done!');
  250.     
  251.     InitConfig (Compressor);
  252.     Write ('Compressing ', DATname, ' into ', Msgname, Msgext, ' ... ');
  253.     IF CompressDat (Msgname + Msgext, Compressor)
  254.       THEN WriteLn ('done!')
  255.       ELSE Halt (5);
  256.  
  257.     FindNext (dirinfo);
  258.   END;
  259.   IF (filesdone = 0)
  260.     THEN Halt (1)
  261.     ELSE WriteLn ('Processed ', filesdone, ' file(s).');
  262. END.
  263.